home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / info-service / www / src / fminit2.0 / objective-lisp.l < prev    next >
Encoding:
Text File  |  1992-11-17  |  2.1 KB  |  98 lines
  1. ;; objective-lisp.l -- syntactic extensions to XLisp for OOP
  2. ;;
  3.  
  4. ;
  5. ; extend reader syntax so that [obj args...]
  6. ; reads as (send obj args...)
  7. ;
  8.  
  9. (setf (aref *readtable* (char-int #\[)) ; #\[ table entry
  10.       (cons :tmacro
  11.         (lambda (f c &aux ex ret)    ; second arg is not used
  12.           (do ()
  13.           ((eq (non-comment-char f) #\]))
  14.           (let ((cell (cons (read f) nil))
  15.             )
  16.             (if ex (setf (cdr ex) cell) (setf ret cell))
  17.             (setf ex cell)))
  18.           (read-char f)        ; toss the trailing #\)
  19.           (cons (cons 'send ret) NIL))
  20.         ))
  21.  
  22. (setf (aref *readtable* (char-int #\]))
  23.       (cons :tmacro
  24.         (lambda (f c)
  25.           (error "misplaced right bracket"))))
  26.  
  27.  
  28. (defun non-comment-char (f)
  29.   (do ((c (peek-char t f) (peek-char t f))
  30.        )
  31.       ((not (eq (aref *readtable* (char-int c))
  32.         (aref *readtable* (char-int #\;))))
  33.        c)
  34.       (read-line f)
  35.       ) )
  36.  
  37.  
  38. ;
  39. ; defclass, defmethod forms
  40. ;
  41.  
  42. ;
  43. ; (defmethod _class_ :selector (args) body...)
  44. ; adds a method to _class_
  45. ;
  46. (defmacro defMethod (cls message arglist &rest body)
  47.   `[,cls :answer ',message ',arglist
  48.      ',body]
  49.   )
  50.  
  51. (defMethod Class :SET-PNAME (NAME)
  52.   (SETF PNAME (STRING NAME))
  53.   )
  54.  
  55. ;
  56. ; (defClassMethod _class_ :selector (args) body...)
  57. ; adds a method to _class_'s metaclass.
  58. ;
  59. (defmacro defClassMethod (cls message arglist &rest body)
  60.   `[[,cls :class] :answer ,message ',arglist
  61.     ',body]
  62.   )
  63.  
  64. ;
  65. ; In order to have class methods, every normal class
  66. ; is an instance of a metaclass. All the metaclasses
  67. ; are instances of class.
  68. ;
  69.  
  70. ;
  71. ; Create the root of the metaclass hierarchy
  72. ;
  73.  
  74. (setf MetaClass [Class :new () () Class])
  75. [MetaClass :set-pname 'MetaClass]
  76.  
  77. (defMethod Class :for (name super)
  78.   (let ((mc [MetaClass :new () () [super :class]])
  79.     )
  80.     [mc :set-pname (concatenate 'string (string name) "-MetaClass")]
  81.     mc
  82.     ) )
  83.  
  84. ;
  85. ; Create a class and its metaclass.
  86. ;
  87.  
  88. (defmacro defClass (cl super &optional ivars cvars)
  89.   (if (null super) (setq super 'Object))
  90.   `(let ((mc [MetaClass :for ',cl ,super])
  91.      )
  92.      (setf ,cl [mc :new ',ivars ',cvars ,super])
  93.      [,cl :set-pname ',cl]
  94.      )
  95.   )
  96.  
  97. (provide 'objective-lisp)
  98.